home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / cmpnew / cmpenv.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1994-05-07  |  24.9 KB  |  671 lines
  1. ;;; CMPENV  Environments of the Compiler.
  2. ;;;
  3. ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  4.  
  5. ;; This file is part of GNU Common Lisp, herein referred to as GCL
  6. ;;
  7. ;; GCL is free software; you can redistribute it and/or modify it under
  8. ;;  the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  9. ;; the Free Software Foundation; either version 2, or (at your option)
  10. ;; any later version.
  11. ;; 
  12. ;; GCL is distributed in the hope that it will be useful, but WITHOUT
  13. ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14. ;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  15. ;; License for more details.
  16. ;; 
  17. ;; You should have received a copy of the GNU Library General Public License 
  18. ;; along with GCL; see the file COPYING.  If not, write to the Free Software
  19. ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21.  
  22. (in-package 'compiler)
  23.  
  24. (defvar *safe-compile* nil)
  25. (defvar *compiler-check-args* nil)
  26. (defvar *compiler-push-events* nil)
  27. (defvar *speed* 3)
  28. (defvar *space* 0)
  29.  
  30. ;;; Only these flags are set by the user.
  31. ;;; If *safe-compile* is ON, some kind of run-time checks are not
  32. ;;; included in the compiled code.  The default value is OFF.
  33.  
  34.  
  35.  
  36. (defun init-env ()
  37.   (setq *next-cvar* 0)
  38.   (setq *next-cmacro* 0)
  39.   (setq *next-vv* -1)
  40.   (setq *next-cfun* 0)
  41.   (setq *last-label* 0)
  42.   (setq *objects* nil)
  43.   (setq *constants* nil)
  44.   (setq *local-funs* nil)
  45.   (setq *global-funs* nil)
  46.   (setq *global-entries* nil)
  47.   (setq *undefined-vars* nil)
  48.   (setq *reservations* nil)
  49.   (setq *closures* nil)
  50.   (setq *top-level-forms* nil)
  51.   (setq *non-package-operation* nil)
  52.   (setq *function-declarations* nil)
  53.   (setq *inline-functions* nil)
  54.   (setq *inline-blocks* 0)
  55.   (setq *notinline* nil)
  56.   )
  57.  
  58. (defvar *next-cvar* 0)
  59. (defvar *next-cmacro* 0)
  60. (defvar *next-vv* -1)
  61. (defvar *next-cfun* 0)
  62.  
  63. ;;; *next-cvar* holds the last cvar number used.
  64. ;;; *next-cmacro* holds the last cmacro number used.
  65. ;;; *next-vv* holds the last VV index used.
  66. ;;; *next-cfun* holds the last cfun used.
  67.  
  68. (defmacro next-cfun () '(incf *next-cfun*))
  69.  
  70. (defun add-symbol (symbol)
  71.   (let ((x (assoc symbol *objects*)))
  72.        (cond (x (cadr x))
  73.              (t (push-data-incf symbol)
  74.                 (push (list symbol *next-vv*) *objects*)
  75.         *next-vv*))))
  76.  
  77. ;; Write to a string with all the *print-.. levels bound appropriately.
  78. (defun wt-to-string (x &aux
  79.                (*compiler-output-data* (make-string-output-stream))
  80.                *fasd-data*)
  81.   (wt-data1 x)
  82.   (get-output-stream-string *compiler-output-data*))
  83.  
  84. (defun add-object (object &aux x)
  85.   ;;; Used only during Pass 1.
  86.   (cond ((si:contains-sharp-comma object)
  87.          ;;; SI:CONTAINS-SHARP-COMMA returns T iff OBJECT
  88.          ;;; contains a sharp comma OR a structure.
  89.      ;; there will be an eval and we want the eval to happen
  90.      (cond ((and
  91.          (consp object)
  92.          (eq (car object) 'si::|#,|)
  93.          (not (si:contains-sharp-comma (cdr object))))
  94.         (setq object (cdr object)))
  95.            (t (setq object `(si::string-to-object
  96.                  ,(wt-to-string object)))))
  97.      (push-data-incf nil)
  98.          (push (list *next-vv* object) *sharp-commas*)
  99.          *next-vv*)
  100.         ((setq x (assoc object *objects*))
  101.          (cadr x))
  102.     ((typep object 'compiled-function)
  103.      (push-data-incf nil)
  104.          (push (list *next-vv* `(function 
  105.                  ,(or (si::compiled-function-name
  106.                        object)
  107.                       (cmperr "Can't dump un named compiled funs")
  108.                       )))
  109.                  *sharp-commas*)
  110.          *next-vv*
  111.      )
  112.         (t 
  113.        (push-data-incf object)
  114.            (push (list object *next-vv*) *objects*)
  115.            *next-vv*)))
  116.  
  117. (defun add-constant (symbol &aux x)
  118.   ;;; Used only during Pass 1.
  119.   (cond ((setq x (assoc symbol *constants*))
  120.          (cadr x))
  121.         (t (push-data-incf nil)
  122.            (push (list *next-vv* symbol) *sharp-commas*)
  123.            (push (list symbol *next-vv*) *constants*)
  124.            *next-vv*)))
  125.  
  126. (defmacro next-cvar () '(incf *next-cvar*))
  127. (defmacro next-cmacro () '(incf *next-cmacro*))
  128.  
  129. ;;; Tail recursion information.
  130. (defvar *do-tail-recursion* t)
  131. (defvar *tail-recursion-info* nil)
  132. ;;; Tail recursion optimization never occurs if *do-tail-recursion* is NIL.
  133. ;;; *tail-recursion-info* holds NIL, if tail recursion is impossible.
  134. ;;; If possible, *tail-recursion-info* holds
  135. ;;;    ( fname  required-arg .... required-arg ),
  136. ;;; where each required-arg is a var-object.
  137.  
  138.  
  139. (defvar *function-declarations* nil)
  140. ;;; *function-declarations* holds :
  141. ;;;    (... ( { function-name | fun-object } arg-types return-type ) ...)
  142. ;;; Function declarations for global functions are ASSOCed by function names,
  143. ;;; whereas those for local functions are ASSOCed by function objects.
  144. ;;;
  145. ;;; The valid argment type declaration is:
  146. ;;;    ( {type}* [ &optional {type}* ] [ &rest type ] [ &key {type}* ] )
  147. ;;; though &optional, &rest, and &key return types are simply ignored.
  148.  
  149. (defun function-arg-types (arg-types &aux vararg (types nil) result)
  150.   (setq result
  151.     (do ((al arg-types (cdr al))
  152.          (i 0 (the fixnum (+ 1 i))))
  153.         ((endp al)
  154.          (reverse types))
  155.         (declare (fixnum i))
  156.         (cond ((or (member (car al) '(&optional &rest &key))
  157.                (equal (car al) '* ))
  158.            (setq vararg t)
  159.            (return (reverse (cons '* types)))))
  160.         ;; only the first 9 args may have proclaimed type different from T
  161.         (push       (cond 
  162.                    ((< i 9)
  163.                 (let ((tem
  164.                        (type-filter (car al))))
  165.                   (if (eq 'integer tem) t tem)))
  166.                   (t (if (eq (car al) '*) '* t)))
  167.             types)))
  168.   ;;only type t args for var arg so far.
  169.   (cond (vararg (do ((v result (cdr v)))
  170.             ((null v))
  171.             (setf (car v) (if (eq (car v) '*) '* t)))))
  172.             
  173.   result)
  174.  
  175.  
  176. ;;; The valid return type declaration is:
  177. ;;;    (( VALUES {type}* )) or ( {type}* ).
  178.  
  179. (defun function-return-type (return-types)
  180.   (and (eq (car return-types) 'values)
  181.        (setq return-types (cdr return-types)))
  182.   (cond ((endp return-types) nil)
  183.         ((and (consp (car return-types))
  184.               (eq (caar return-types) 'values))
  185.      (function-return-type (cdr (car return-types))))
  186.     (t (do ((v return-types (cdr v))
  187.         (result))
  188.            ((endp v)(or (null v)
  189.                 (warn "The function return type ~s is illegal."
  190.                   return-types))
  191.         (nreverse result))
  192.          (let ((tem  (if (eq (car v) '*) '* (type-filter (car v)))))
  193.            (if (eq tem 'integer) (setq tem t))
  194.            (push  tem result))))))
  195.         
  196. (defun add-function-proclamation (fname decl list &aux (procl t)
  197.                     arg-types return-types)
  198.   (cond
  199.     ((and (symbolp fname)
  200.       (listp decl) (listp (cdr decl)))
  201.      (cond ((or (null decl)(eq (car decl) '*)) (setq arg-types '(*)))
  202.        (t (setq arg-types (function-arg-types (car decl)))
  203.  
  204.           ))
  205.      (setq return-types (function-return-type (cdr decl)))
  206.      (cond ((and (consp return-types)  ; ie not nil
  207.          (endp (cdr return-types))
  208.          (not (eq (car return-types) '*)))
  209.         (setq return-types
  210.           ;; varargs must return type t currently.
  211.           (if (member '* (and (consp arg-types) arg-types)) t
  212.               (car return-types))))
  213.        (t (setq procl nil)))
  214.      (cond ((and (listp arg-types)
  215.          (< (length arg-types) call-arguments-limit)))
  216.        (t (setq procl nil)))
  217.      (do ((fname fname (car list)))
  218.      (())
  219.      (or (symbolp fname)
  220.          (return (add-function-proclamation fname decl nil)))
  221.      (if (eq arg-types '*)
  222.          (remprop fname  'proclaimed-arg-types)
  223.        (si:putprop fname  arg-types  'proclaimed-arg-types))
  224.      (si:putprop fname return-types  'proclaimed-return-type)
  225.      
  226.      ;;; A non-local function may have local entry only if it returns
  227.      ;;; a single value.
  228.  
  229.      (if procl  (si:putprop fname t 'proclaimed-function)
  230.        (remprop fname 'proclaimed-function))
  231.      (setq list (cdr list))
  232.      (or (consp list) (return 'done))
  233.      ))
  234.     (t (warn "The function procl ~s ~s is not valid." fname decl))))
  235.  
  236. (defun add-function-declaration (fname arg-types return-types)
  237.   (cond ((symbolp fname)
  238.          (push (list (sch-local-fun fname)
  239.                      (function-arg-types arg-types)
  240.                      (function-return-type return-types))
  241.                *function-declarations*))
  242.         (t (warn "The function name ~s is not a symbol." fname))))
  243.  
  244. (defun get-arg-types (fname &aux x)
  245.   (if (setq x (assoc fname *function-declarations*))
  246.       (cadr x)
  247.       (get fname 'proclaimed-arg-types)))
  248.  
  249. (defun get-return-type (fname)
  250.   (let* ((x (assoc fname *function-declarations*))
  251.          (type1 (if x (caddr x) (get fname 'proclaimed-return-type)))
  252.      (type (if (get fname 'predicate) 'boolean
  253.          (get fname 'return-type))))
  254.         (cond (type1
  255.            (cond (type
  256.               (cond ((setq type (type-and type type1)) type)
  257.                 (t
  258.                  (cmpwarn
  259.                   "The return type of ~s was badly declared."
  260.                   fname))))
  261.              (t type1)))
  262.               (t type))))
  263.  
  264. (defun get-local-arg-types (fun &aux x)
  265.   (if (setq x (assoc fun *function-declarations*))
  266.       (cadr x)
  267.       nil))
  268.  
  269. (defun get-local-return-type (fun &aux x)
  270.   (if (setq x (assoc fun *function-declarations*))
  271.       (caddr x)
  272.       nil))
  273.  
  274. (defvar *sup-used* nil)
  275. (defvar *base-used* nil)
  276.  
  277. (defun reset-top ()
  278.        (wt "vs_top=sup;")
  279.        (setq *sup-used* t))
  280.  
  281. (defmacro base-used () '(setq *base-used* t))
  282.  
  283. ;;; Proclamation and declaration handling.
  284.  
  285. (defvar *alien-declarations* nil)
  286. (defvar *notinline* nil)
  287.  
  288. (defun inline-possible (fname)
  289.        (not (or *compiler-push-events*
  290.                 (member fname *notinline*)
  291.                 (get fname 'cmp-notinline))))
  292.  
  293. (defun proclaim (decl)
  294.   (case (car decl)
  295.     (special
  296.      (dolist** (var (cdr decl))
  297.        (if (symbolp var)
  298.            (si:*make-special var)
  299.            (warn "The variable name ~s is not a symbol." var))))
  300.     (optimize
  301.      (dolist (x (cdr decl))
  302.        (when (symbolp x) (setq x (list x 3)))
  303.        (if (or (not (consp x))
  304.                (not (consp (cdr x)))
  305.                (not (numberp (cadr x)))
  306.                (not (<= 0 (cadr x) 3)))
  307.            (warn "The OPTIMIZE proclamation ~s is illegal." x)
  308.            (case (car x)
  309.                  (safety (setq *compiler-check-args* (>= (cadr x) 1))
  310.                          (setq *safe-compile* (>= (cadr x) 2))
  311.                          (setq *compiler-push-events* (>= (cadr x) 3)))
  312.                  (space (setq *space* (cadr x)))
  313.                  (speed (setq *speed* (cadr x)))
  314.                  (compilation-speed (setq *speed* (- 3 (cadr x))))
  315.                  (t (warn "The OPTIMIZE quality ~s is unknown." (car x)))))))
  316.     (type
  317.      (if (consp (cdr decl))
  318.          (proclaim-var (cadr decl) (cddr decl))
  319.          (warn "The type declaration ~s is illegal." decl)))
  320.     ((fixnum character short-float long-float)
  321.      (proclaim-var (car decl) (cdr decl)))
  322.     (ftype
  323.       (cond ((and (consp (cdr decl))
  324.           (consp (cadr decl))
  325.           (eq (caadr decl) 'function))
  326.          (add-function-proclamation (caddr decl) (cdr (cadr decl))
  327.                     (cddr decl)))
  328.       (t (cmpwarn "Bad function proclamation ~a" decl))))
  329.    (function
  330.     (cond ((and (consp (cdr decl)))
  331.         (add-function-proclamation (cadr decl) (cddr decl) nil))
  332.       (t (cmpwarn "Bad function proclamation ~a" decl))))
  333.     (inline
  334.      (dolist** (fun (cdr decl))
  335.                (if (symbolp fun)
  336.                    (remprop fun 'cmp-notinline)
  337.                    (warn "The function name ~s is not a symbol." fun))))
  338.     (notinline
  339.      (dolist** (fun (cdr decl))
  340.                (if (symbolp fun)
  341.                    (si:putprop fun t 'cmp-notinline)
  342.                    (warn "The function name ~s is not a symbol." fun))))
  343.     ((object ignore)
  344.      (dolist** (var (cdr decl))
  345.        (unless (symbolp var)
  346.                (warn "The variable name ~s is not a symbol." var))))
  347.     (declaration
  348.      (dolist** (x (cdr decl))
  349.        (if (symbolp x)
  350.            (unless (member x *alien-declarations*)
  351.                    (push x *alien-declarations*))
  352.            (warn "The declaration specifier ~s is not a symbol." x))))
  353.     ((array atom bignum bit bit-vector character common compiled-function
  354.       complex cons double-float fixnum float hash-table integer keyword list
  355.       long-float nil null number package pathname random-state ratio rational
  356.       readtable sequence short-float simple-array simple-bit-vector
  357.       simple-string simple-vector single-float standard-char stream string
  358.       string-char symbol t vector signed-byte unsigned-byte)
  359.      (proclaim-var (car decl) (cdr decl)))
  360.     (otherwise
  361.      (unless (member (car decl) *alien-declarations*)
  362.              (warn "The declaration specifier ~s is unknown." (car decl)))
  363.    (and (functionp (get (car decl) :proclaim))
  364.         (dolist** (v (cdr decl))
  365.           (funcall (get (car decl) :proclaim) v)))
  366. )
  367.     )
  368.   nil
  369.   )
  370.  
  371. (defun proclaim-var (type vl)
  372.   (setq type (type-filter type))
  373.   (dolist** (var vl)
  374.     (cond ((symbolp var)
  375.            (let ((type1 (get var 'cmp-type))
  376.                  (v (sch-global var)))
  377.                 (setq type1 (if type1 (type-and type1 type) type))
  378.                 (when v (setq type1 (type-and type1 (var-type v))))
  379.                 (when (null type1) (warn
  380.       "Inconsistent type declaration was found for the variable ~s."
  381.                                     var))
  382.                 (si:putprop var type1 'cmp-type)
  383.                 (when v (setf (var-type v) type1))))
  384.           (t
  385.            (warn "The variable name ~s is not a symbol." var)))))
  386.  
  387. (defun c1body (body doc-p &aux (ss nil) (is nil) (ts nil) (others nil)
  388.                     doc form)
  389.   (loop
  390.     (when (endp body) (return))
  391.     (setq form (cmp-macroexpand (car body)))
  392.     (cond
  393.      ((stringp form)
  394.       (when (or (null doc-p) (endp (cdr body)) doc) (return))
  395.       (setq doc form))
  396.      ((and (consp form) (eq (car form) 'declare))
  397.       (dolist** (decl (cdr form))
  398.         (cmpck (or (not (consp decl)) (not (symbolp (car decl))))
  399.                "The declaration ~s is illegal." decl)
  400.         (case (car decl)
  401.           (special
  402.            (dolist** (var (cdr decl))
  403.              (cmpck (not (symbolp var))
  404.                     "The special declaration ~s contains a non-symbol ~s."
  405.                     decl var)
  406.              (push var ss)))
  407.           (ignore
  408.            (dolist** (var (cdr decl))
  409.              (cmpck (not (symbolp var))
  410.                     "The ignore declaration ~s contains a non-symbol ~s."
  411.                     decl var)
  412.              (push var is)))
  413.           (type
  414.            (cmpck (endp (cdr decl))
  415.                   "The type declaration ~s is illegal." decl)
  416.            (let ((type (type-filter (cadr decl))))
  417.                 (when type
  418.                       (dolist** (var (cddr decl))
  419.                         (cmpck (not (symbolp var))
  420.                           "The type declaration ~s contains a non-symbol ~s."
  421.                           decl var)
  422.                         (push (cons var type) ts)))))
  423.           (object
  424.            (dolist** (var (cdr decl))
  425.              (cmpck (not (symbolp var))
  426.                     "The object declaration ~s contains a non-symbol ~s."
  427.                     decl var)
  428.              (push (cons var 'object) ts)))
  429.       (:register
  430.            (dolist** (var (cdr decl))
  431.              (cmpck (not (symbolp var))
  432.                     "The register declaration ~s contains a non-symbol ~s."
  433.                     decl var)
  434.          (push (cons var  'register) ts)
  435.          ))
  436.           ((fixnum character double-float short-float array atom bignum bit
  437.             bit-vector common compiled-function complex cons float hash-table
  438.             integer keyword list long-float nil null number package pathname
  439.             random-state ratio rational readtable sequence simple-array
  440.             simple-bit-vector simple-string simple-vector single-float
  441.             standard-char stream string string-char symbol t vector
  442.             signed-byte unsigned-byte :dynamic-extent)
  443.            (let ((type (if (eq (car decl) ':dynamic-extent) (car decl)
  444.              (type-filter (car decl)))))
  445.                 (when type
  446.                       (dolist** (var (cdr decl))
  447.                         (cmpck (not (symbolp var))
  448.                           "The type declaration ~s contains a non-symbol ~s."
  449.                           decl var)
  450.                         (push (cons var type) ts)))))
  451.           (otherwise (push decl others))
  452.           )))
  453.      (t (return)))
  454.     (pop body)
  455.     )
  456.   (values body ss ts is others doc)
  457.   )
  458.  
  459. (defun c1decl-body (decls body &aux (dl nil))
  460.   (if (null decls)
  461.       (c1progn body)
  462.       (let ((*function-declarations* *function-declarations*)
  463.             (*alien-declarations* *alien-declarations*)
  464.             (*notinline* *notinline*)
  465.             (*space* *space*)
  466.         (*safe-compile* *safe-compile*))
  467.            (dolist** (decl decls dl)
  468.              (case (car decl)
  469.               (optimize
  470.                (dolist (x (cdr decl))
  471.                  (when (symbolp x) (setq x (list x 3)))
  472.                  (if (or (not (consp x))
  473.                          (not (consp (cdr x)))
  474.                          (not (numberp (cadr x)))
  475.                          (not (<= 0 (cadr x) 3)))
  476.                      (warn "The OPTIMIZE proclamation ~s is illegal." x)
  477.                      (case (car x)
  478.                            (safety
  479.                  (setq *safe-compile*
  480.                    (>= (the fixnum (cadr x)) 2))
  481.                  (push (list 'safety (cadr x)) dl))
  482.                            (space (setq *space* (cadr x))
  483.                                   (push (list 'space (cadr x)) dl))
  484.                            ((speed compilation-speed))
  485.                            (t (warn "The OPTIMIZE quality ~s is unknown."
  486.                                     (car x)))))))
  487.               (ftype
  488.                (if (or (endp (cdr decl))
  489.                        (not (consp (cadr decl)))
  490.                        (not (eq (caadr decl) 'function))
  491.                        (endp (cdadr decl)))
  492.                    (warn "The function declaration ~s is illegal." decl)
  493.                    (dolist** (fname (cddr decl))
  494.                      (add-function-declaration
  495.                       fname (cadadr decl) (cddadr decl)))))
  496.               (function
  497.                (if (or (endp (cdr decl))
  498.                        (endp (cddr decl))
  499.                        (not (symbolp (cadr decl))))
  500.                    (warn "The function declaration ~s is illegal." decl)
  501.                    (add-function-declaration
  502.                     (cadr decl) (caddr decl) (cdddr decl))))
  503.               (inline
  504.                (dolist** (fun (cdr decl))
  505.                  (if (symbolp fun)
  506.                      (progn (push (list 'inline fun) dl)
  507.                             (setq *notinline* (remove fun *notinline*)))
  508.                      (warn "The function name ~s is not a symbol." fun))))
  509.               (notinline
  510.                (dolist** (fun (cdr decl))
  511.                  (if (symbolp fun)
  512.                      (progn (push (list 'notinline fun) dl)
  513.                             (push fun *notinline*))
  514.                      (warn "The function name ~s is not a symbol." fun))))
  515.               (declaration
  516.                (dolist** (x (cdr decl))
  517.                  (if (symbolp x)
  518.                      (unless (member x *alien-declarations*)
  519.                              (push x *alien-declarations*))
  520.                      (warn "The declaration specifier ~s is not a symbol."
  521.                            x))))
  522.               (otherwise
  523.                (unless (member (car decl) *alien-declarations*)
  524.                  (warn "The declaration specifier ~s is unknown."
  525.                        (car decl))))
  526.               ))
  527.            (setq body (c1progn body))
  528.            (list 'decl-body (cadr body) dl body)
  529.            )
  530.       )
  531.   )
  532.  
  533. (si:putprop 'decl-body 'c2decl-body 'c2)
  534.  
  535. (defun c2decl-body (decls body)
  536.   (let ((*compiler-check-args* *compiler-check-args*)
  537.         (*safe-compile* *safe-compile*)
  538.         (*compiler-push-events* *compiler-push-events*)
  539.         (*notinline* *notinline*)
  540.         (*space* *space*)
  541.     )
  542.        (dolist** (decl decls)
  543.          (case (car decl)
  544.                (safety
  545.                 (let ((level (cadr decl)))
  546.                      (declare (fixnum level))
  547.                      (setq *compiler-check-args* (>= level 1)
  548.                            *safe-compile* (>= level 2)
  549.                            *compiler-push-events* (>= level 3))))
  550.                (space (setq *space* (cadr decl)))
  551.                (notinline (push (cadr decl) *notinline*))
  552.                (inline
  553.                 (setq *notinline* (remove (cadr decl) *notinline*)))
  554.                (otherwise (baboon))))
  555.        (c2expr body))
  556.   )
  557.  
  558. (defun check-vdecl (vnames ts is)
  559.   (dolist** (x ts)
  560.     (unless (member (car x) vnames)
  561.       (cmpwarn "Type declaration was found for not bound variable ~s."
  562.                (car x))))
  563.   (dolist** (x is)
  564.     (unless (member x vnames)
  565.       (cmpwarn "Ignore declaration was found for not bound variable ~s." x)))
  566.   )
  567.  
  568. (defun proclamation (decl)
  569.   (case (car decl)
  570.     (special
  571.      (dolist** (var (cdr decl) t)
  572.        (if (symbolp var)
  573.            (unless (si:specialp var) (return nil))
  574.            (warn "The variable name ~s is not a symbol." var))))
  575.     (optimize
  576.      (dolist (x (cdr decl) t)
  577.        (when (symbolp x) (setq x (list x 3)))
  578.        (if (or (not (consp x))
  579.                (not (consp (cdr x)))
  580.                (not (numberp (cadr x)))
  581.                (not (<= 0 (cadr x) 3)))
  582.            (warn "The OPTIMIZE proclamation ~s is illegal." x)
  583.            (case (car x)
  584.                  (safety
  585.                   (unless (= (cadr x)
  586.                              (cond ((null *compiler-check-args*) 0)
  587.                                    ((null *safe-compile*) 1)
  588.                                    ((null *compiler-push-events*) 2)
  589.                                    (t 3)))
  590.                           (return nil)))
  591.                  (space (unless (= (cadr x) *space*) (return nil)))
  592.                  (speed (unless (= (cadr x) *speed*) (return nil)))
  593.                  (compilation-speed
  594.                   (unless (= (- 3 (cadr x)) *speed*) (return nil)))
  595.                  (t (warn "The OPTIMIZE quality ~s is unknown."
  596.                           (car x)))))))
  597.     (type
  598.      (if (consp (cdr decl))
  599.          (let ((type (type-filter (cadr decl)))
  600.                x)
  601.               (dolist** (var (cddr decl) t)
  602.                 (if (symbolp var)
  603.                     (unless (and (setq x (get var 'cmp-type))
  604.                                  (equal x type))
  605.                             (return nil))
  606.                     (warn "The variable name ~s is not a symbol." var))))
  607.          (warn "The type declaration ~s is illegal." decl)))
  608.     ((fixnum character short-float long-float)
  609.      (let ((type (type-filter (car decl)))
  610.            x)
  611.           (dolist** (var (cdr decl) t)
  612.             (if (symbolp var)
  613.                 (unless (and (setq x (get var 'cmp-type)) (equal x type))
  614.                         (return nil))
  615.                 (warn "The variable name ~s is not a symbol." var)))))
  616.     (ftype
  617.      (if (or (endp (cdr decl))
  618.              (not (consp (cadr decl)))
  619.              (not (eq (caadr decl) 'function))
  620.              (endp (cdadr decl)))
  621.          (warn "The function declaration ~s is illegal." decl)
  622.          (dolist** (fname (cddr decl) t)
  623.            (unless (and (get fname 'proclaimed-function)
  624.                         (equal (function-arg-types (cadadr decl))
  625.                                (get fname 'proclaimed-arg-types))
  626.                         (equal (function-return-type (cddadr decl))
  627.                                (get fname 'proclaimed-return-type)))
  628.                    (return nil)))))
  629.     (function
  630.      (if (or (endp (cdr decl)) (endp (cddr decl)))
  631.          (warn "The function declaration ~s is illegal." decl)
  632.          (and (get (cadr decl) 'proclaimed-function)
  633.               (equal (function-arg-types (caddr decl))
  634.                      (get (cadr decl) 'proclaimed-arg-types))
  635.               (equal (function-return-type (cdddr decl))
  636.                      (get (cadr decl) 'proclaimed-return-type)))))
  637.     (inline (dolist** (fun (cdr decl) t)
  638.               (if (symbolp fun)
  639.                   (when (get fun 'cmp-notinline) (return nil))
  640.                   (warn "The function name ~s is not a symbol." fun))))
  641.     (notinline (dolist** (fun (cdr decl) t)
  642.                  (if (symbolp fun)
  643.                      (unless (get fun 'cmp-notinline) (return nil))
  644.                      (warn "The function name ~s is not a symbol." fun))))
  645.     ((object ignore)
  646.      (dolist** (var (cdr decl) t)
  647.                (unless (symbolp var)
  648.                        (warn "The variable name ~s is not a symbol." var))))
  649.     (declaration (dolist** (x (cdr decl) t)
  650.                    (if (symbolp x)
  651.                        (unless (member x *alien-declarations*) (return nil))
  652.                        (warn "The declaration specifier ~s is not a symbol."
  653.                              x))))
  654.     ((array atom bignum bit bit-vector character common compiled-function
  655.       complex cons double-float fixnum float hash-table integer keyword list
  656.       long-float nil null number package pathname random-state ratio rational
  657.       readtable sequence short-float simple-array simple-bit-vector
  658.       simple-string simple-vector single-float standard-char stream string
  659.       string-char symbol t vector signed-byte unsigned-byte)
  660.      (let ((type (type-filter (car decl))))
  661.           (dolist** (var (cdr decl) t)
  662.             (if (symbolp var)
  663.                 (unless (equal (get var 'cmp-type) type) (return nil))
  664.                 (warn "The variable name ~s is not a symbol." var)))))
  665.     (otherwise
  666.      (unless (member (car decl) *alien-declarations*)
  667.              (warn "The declaration specifier ~s is unknown." (car decl))))
  668.     )
  669.   )
  670.  
  671.